home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-mail.el.z / url-mail.el
Encoding:
Text File  |  1998-05-21  |  6.6 KB  |  198 lines
  1. ;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/17 14:08:03
  4. ;; Version: 1.9
  5. ;; Keywords: comm, data, processes
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (require 'url-vars)
  30. (require 'url-parse)
  31.  
  32. (defmacro url-mailserver-skip-chunk ()
  33.   (` (while (and (not (looking-at "/"))
  34.          (not (eobp)))
  35.        (forward-sexp 1))))
  36.  
  37. ;;;###autoload
  38. (defun url-mail (&rest args)
  39.   (interactive "P")
  40.   (if (fboundp 'message-mail)
  41.       (apply 'message-mail args)
  42.     (or (apply 'mail args)
  43.     (error "Mail aborted"))))
  44.  
  45. (defun url-mail-goto-field (field)
  46.   (if (not field)
  47.       (goto-char (point-max))
  48.     (let ((dest nil)
  49.       (lim nil)
  50.       (case-fold-search t))
  51.       (save-excursion
  52.     (goto-char (point-min))
  53.     (if (re-search-forward (regexp-quote mail-header-separator) nil t)
  54.         (setq lim (match-beginning 0)))
  55.     (goto-char (point-min))
  56.     (if (re-search-forward (concat "^" (regexp-quote field) ":") lim t)
  57.         (setq dest (match-beginning 0))))
  58.       (if dest
  59.       (progn
  60.         (goto-char dest)
  61.         (end-of-line))
  62.     (goto-char lim)
  63.     (insert (capitalize field) ": ")
  64.     (save-excursion
  65.       (insert "\n"))))))
  66.   
  67. (defun url-mailto (url)
  68.   ;; Send mail to someone
  69.   (if (not (string-match "mailto:/*\\(.*\\)" url))
  70.       (error "Malformed mailto link: %s" url))
  71.   (setq url (substring url (match-beginning 1) nil))
  72.   (if (get-buffer url-working-buffer)
  73.       (kill-buffer url-working-buffer))
  74.   (let (to args source-url subject func)
  75.     (if (string-match (regexp-quote "?") url)
  76.     (setq to (url-unhex-string (substring url 0 (match-beginning 0)))
  77.           args (url-parse-query-string
  78.             (substring url (match-end 0) nil) t))
  79.       (setq to (url-unhex-string url)))
  80.     (setq source-url (url-view-url t))
  81.     (if (and url-request-data (not (assoc "subject" args)))
  82.     (setq args (cons (list "subject"
  83.                    (concat "Automatic submission from "
  84.                        url-package-name "/"
  85.                        url-package-version)) args)))
  86.     (if (and source-url (not (assoc "x-url-from" args)))
  87.     (setq args (cons (list "x-url-from" source-url) args)))
  88.     (setq args (cons (list "to" to) args)
  89.       subject (cdr-safe (assoc "subject" args)))
  90.     (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
  91.     (while args
  92.       (url-mail-goto-field (caar args))
  93.       (setq func (intern-soft (concat "mail-" (caar args))))
  94.       (insert (mapconcat 'identity (cdar args) ", "))
  95.       (setq args (cdr args)))
  96.     (url-mail-goto-field "X-Mailer")
  97.     (insert url-package-name "/" url-package-version)
  98.     (if (not url-request-data)
  99.     (if subject
  100.         (url-mail-goto-field nil)
  101.       (url-mail-goto-field "subject"))
  102.       (if url-request-extra-headers
  103.       (mapconcat
  104.        (function
  105.         (lambda (x)
  106.           (url-mail-goto-field (car x))
  107.           (insert (cdr x))))
  108.        url-request-extra-headers ""))
  109.       (goto-char (point-max))
  110.       (insert url-request-data)
  111.       (mail-send-and-exit nil))))
  112.  
  113. (defun url-mailserver (url)
  114.   ;; Send mail to someone, much cooler/functional than mailto
  115.   (if (get-buffer url-working-buffer)
  116.       (kill-buffer url-working-buffer))
  117.   (set-buffer (get-buffer-create " *mailserver*"))
  118.   (erase-buffer)
  119.   (insert url)
  120.   (goto-char (point-min))
  121.   (set-syntax-table url-mailserver-syntax-table)
  122.   (skip-chars-forward "^:")        ; Get past mailserver
  123.   (skip-chars-forward ":")        ; Get past :
  124.   ;; Handle some ugly malformed URLs, but bitch about it.
  125.   (if (looking-at "/")
  126.       (progn
  127.     (url-warn 'url "Invalid mailserver URL... attempting to cope.")
  128.     (skip-chars-forward "/")))
  129.   
  130.   (let ((save-pos (point))
  131.     (url (url-view-url t))
  132.     (rfc822-addr nil)
  133.     (subject nil)
  134.     (body nil))
  135.     (url-mailserver-skip-chunk)
  136.     (setq rfc822-addr (buffer-substring save-pos (point)))
  137.     (forward-char 1)
  138.     (setq save-pos (point))
  139.     (url-mailserver-skip-chunk)
  140.     (setq subject (buffer-substring save-pos (point)))
  141.     (if (not (eobp))
  142.     (progn                ; There is some text to use
  143.       (forward-char 1)        ; as the body of the message
  144.       (setq body (buffer-substring (point) (point-max)))))
  145.     (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
  146.     (url-mail-goto-field "to")
  147.     (insert rfc822-addr)
  148.     (if (and url (not (string= url "")))
  149.     (progn
  150.       (url-mail-goto-field "X-URL-From")
  151.       (insert url)))
  152.     (url-mail-goto-field "X-Mailer")
  153.     (insert url-package-name "/" url-package-version)
  154.     (url-mail-goto-field "subject")
  155.     ;; Massage the subject from URLEncoded garbage
  156.     ;; Note that we do not allow any newlines in the subject,
  157.     ;; as recommended by the Internet Draft on the mailserver
  158.     ;; URL - this means the document author cannot spoof additional
  159.     ;; header lines, which is a 'Good Thing'
  160.     (if subject
  161.     (progn
  162.       (setq subject (url-unhex-string subject))
  163.       (let ((x (1- (length subject)))
  164.         (y 0))
  165.         (while (<= y x)
  166.           (if (memq (aref subject y) '(?\r ?\n))
  167.           (aset subject y ? ))
  168.           (setq y (1+ y))))))
  169.     (insert subject)
  170.     (if url-request-extra-headers
  171.     (progn
  172.       (goto-char (point-min))
  173.       (insert
  174.        (mapconcat
  175.         (function
  176.          (lambda (x)
  177.            (url-mail-goto-field (car x))
  178.            (insert (cdr x))))
  179.         url-request-extra-headers ""))))
  180.     (goto-char (point-max))
  181.     ;; Massage the body from URLEncoded garbage
  182.     (if body
  183.     (let ((x (1- (length body)))
  184.           (y 0))
  185.       (while (<= y x)
  186.         (if (= (aref body y) ?/)
  187.         (aset body y ?\n))
  188.         (setq y (1+ y)))
  189.       (setq body (url-unhex-string body))))
  190.     (and body (insert body))
  191.     (and url-request-data (insert url-request-data))
  192.     (if (and (or body url-request-data)
  193.          (funcall url-confirmation-func
  194.               (concat "Send message to " rfc822-addr "? ")))
  195.     (mail-send-and-exit nil))))    
  196.  
  197. (provide 'url-mail)
  198.